home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / struct.t < prev    next >
Text File  |  1989-06-30  |  11KB  |  243 lines
  1. (herald struct (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; (define-structure-type ship 
  27. ;;;   x
  28. ;;;   y  
  29. ;;;   (handler ((print self port) (...)) =>
  30. ;;; 
  31. ;;; (block (define ship-stype  (make-stype 'ship '(x y)))
  32. ;;;        (define make-ship   (stype-constructor ship-stype))
  33. ;;;        (define ship?       (stype-predicator ship-stype))
  34. ;;;        (define ship-x      (stype-selector ship-stype 'x))
  35. ;;;        (define ship-y      (stype-selector ship-stype 'y))
  36. ;;;        ship-stype)
  37.  
  38.  
  39. ;;; Structures look like this: e.g. (define-structure-type foo a b c) (VAX)
  40.  
  41. ;;;    ----------------------------------------------
  42. ;;;--> |   foo-stype  template                      | -------
  43. ;;;    ----------------------------------------------       |
  44. ;;;    |        component a                         |       |
  45. ;;;    ---------------------------------------------|       |
  46. ;;;    |        component b                         |       | 
  47. ;;;    ---------------------------------------------|       |
  48. ;;;    |        component c                         |       |
  49. ;;;    ----------------------------------------------       |
  50. ;;;                                                         |
  51. ;;;                                                         |
  52. ;;;                                                         |
  53. ;;;                                                         |
  54. ;;;                                                         |
  55. ;;;    ---------------------------------------------------  |
  56. ;;;    |           *stype-template*                      |  |
  57. ;;;    ---------------------------------------------------  |
  58. ;;;    |                handler                          |  |
  59. ;;;    ---------------------------------------------------  |
  60. ;;;    |                predicator                       |  |
  61. ;;;    ---------------------------------------------------  |
  62. ;;;    |                constructor                      |  |
  63. ;;;    ---------------------------------------------------  |
  64. ;;;    |                selectors                        |  |
  65. ;;;    ---------------------------------------------------  |
  66. ;;;    |                master                           |  |
  67. ;;;    ---------------------------------------------------  |
  68. ;;;    |                id                               |  |
  69. ;;;    ---------------------------------------------------| |
  70. ;;;    |  pointer | scratch    |         8             | 0| |
  71. ;;;    ---------------------------------------------------| |
  72. ;;;    |  jump absolute opcode |     0      | template    |<-   H = 1, I = 0
  73. ;;;    ---------------------------------------------------|
  74. ;;;    |          *structure-template*                    |
  75. ;;;    ----------------------------------------------------
  76. ;;; 
  77.  
  78. (define (default-structure-handler stype)
  79.   (object nil          
  80.     ((crawl-exhibit self)
  81.      (exhibit-structure self))
  82.     ((print self port) (print-structure self port))
  83.     ((structure-type self) stype)))
  84.  
  85.  
  86. (define-operation (selector-id obj))              
  87.         
  88. (define-operation (structure-type obj) nil)    
  89.  
  90. (define-integrable (stype? obj)
  91.   (and (extend? obj) (eq? (extend-header obj) *stype-template*)))
  92.                              
  93. (define-integrable (structure? obj)
  94.   (true? (structure-type obj)))
  95.      
  96.  
  97. (define (copy-structure struct)
  98.   (let* ((struct (enforce structure? struct))
  99.          (template (extend-header struct))
  100.          (size (template-pointer-slots template)))
  101.     (%copy-extend (%make-extend template size) struct size)))
  102.  
  103. (define (copy-structure! to-struct from-struct)
  104.    (let ((to-struct (enforce structure? to-struct))
  105.          (from-struct (enforce structure? from-struct)))
  106.     (cond ((not (eq? (extend-header from-struct) (extend-header to-struct)))
  107.            (copy-structure! (error "structure types don't match~%  ~s"
  108.                                    `(copy-structure ,to-struct ,from-struct))
  109.                             from-struct))
  110.           (else
  111.            (%copy-extend to-struct 
  112.                          from-struct 
  113.                          (template-pointer-slots (extend-header to-struct)))))))
  114.  
  115.     
  116.  
  117. (define (make-stype type-id specs handler)
  118.   (let ((size (length specs)))
  119.     (receive (template stype) (make-structure-template size)
  120.       (set (stype-predicator stype)
  121.            (object (lambda (obj)
  122.                      (and (extend? obj) (eq? (extend-header obj) template)))
  123.                    ((print self port)
  124.                     (format port "#{Structure-predicator~_~S}" type-id))))
  125.       (set (stype-constructor stype)
  126.            (object (lambda ()
  127.                      (copy-structure (stype-master stype)))
  128.                    ((print self port)
  129.                     (format port "#{Structure-constructor~_~s}"
  130.                             type-id))))                    
  131.       (set (stype-master stype)
  132.            (%make-extend template size))
  133.       (set (stype-selectors stype)
  134.            (do ((index 0 (fx+ index 1))
  135.                 (specs specs (cdr specs))
  136.                 (sels '()
  137.                       (cons (make-struct-selector stype
  138.                                                   template
  139.                                                   (car specs)
  140.                                                   index)
  141.                             sels)))
  142.                ((null? specs) (reverse! sels))))
  143.       (set (stype-id stype) type-id)
  144.       (set (stype-handler stype) 
  145.            (if handler
  146.                (join handler (default-structure-handler stype))
  147.                (default-structure-handler stype)))
  148.       (let ((master (stype-master stype)))
  149.         (walk1 (lambda (sel)
  150.                  (set (sel master) *exhibit-structure-photon*))
  151.               (stype-selectors stype)))
  152.       stype)))
  153.  
  154. (define handle-stype
  155.   (object nil
  156.     ((print self port)
  157.      (format port "#{Structure-type~_~s}" (stype-id self)))))
  158.  
  159.                                                            
  160. (define (stype-selector stype id)
  161.   (cond ((not (stype? stype))
  162.          (error "attempt to take stype-selector of ~s which is not an stype"
  163.                 stype))
  164.         ((mem (lambda (id sel) (eq? id (selector-id sel)))
  165.               id
  166.               (stype-selectors stype))
  167.          => car)
  168.         (else
  169.          (error "structure type ~S has no such selector name~%  ~S"
  170.                 stype
  171.                 `(stype-selector ,stype ,id)))))
  172.  
  173.  
  174. (define (print-structure struct port)
  175.   (format port
  176.           "#{Structure~_~s~_~s}"
  177.           (stype-id (structure-type struct))
  178.           (object-hash struct)))
  179.  
  180. (define (make-struct-selector stype template spec index)
  181.   (let ((the-setter
  182.          (lambda (obj new-value)
  183.            (iterate loop ((obj obj))
  184.              (cond ((and (extend? obj) 
  185.                          (eq? (extend-header obj) template))
  186.                     (set (extend-pointer-elt obj index) 
  187.                          new-value))
  188.                    (else
  189.                     (loop (error '("attempt to alter the ~s component of ~s,~%"
  190.                                  "which is not of structure type ~s, to be ~s")
  191.                                  spec
  192.                                  obj
  193.                                  (stype-id stype)
  194.                                  new-value))))))))
  195.     (object (lambda (obj)
  196.               (iterate loop ((obj obj))
  197.                 (cond ((and (extend? obj)
  198.                             (eq? (extend-header obj) template))
  199.                        (let ((probe (extend-pointer-elt obj index)))
  200.                          (cond ((eq? *exhibit-structure-photon*
  201.                                      probe)
  202.                                 (error '("attempt to access uninitialized ~s "
  203.                                          "component of ~s")
  204.                                        spec
  205.                                        obj))
  206.                                (else probe))))
  207.                       (else
  208.                        (loop
  209.                         (error '("attempt to access the ~s component of ~s,~%"
  210.                                  "which is not of structure type ~s")
  211.                                spec
  212.                                obj
  213.                                (stype-id stype)))))))
  214.             ((setter self) the-setter)
  215.             ((selector-id self) spec)
  216.             ((print self port)
  217.              (format port "#{Selector~_~s~_~s}"
  218.                      (stype-id stype)
  219.                      spec)))))
  220.  
  221. (define (stype-compatible? stype id specs)
  222.   (ignore id)
  223.   (and (stype? stype)
  224.        (iterate loop ((s specs)
  225.                       (z (stype-selectors stype)))
  226.          (cond ((null? s) (null? z))
  227.                ((null? z) nil)
  228.                ((neq? (car s) (selector-id (car z))) nil)
  229.                (else (loop (cdr s) (cdr z)))))))
  230.  
  231. (define (exhibit-structure struct)
  232.   (let ((sels (stype-selectors (structure-type struct))))
  233.     (do ((s sels (cdr s))
  234.          (i 0 (fx+ i 1)))
  235.         ((null? s))
  236.       (let ((val (extend-pointer-elt struct i))) ;;((car s) struct)))
  237.         (crawl-print-component (selector-id (car s)) val)))))
  238.  
  239. (define *exhibit-structure-photon*      ; ugh
  240.   (object nil
  241.     ((print self port)
  242.      (write-string port "Uninitialized structure slot"))))
  243.